1 Primary market purchases (38 orders)

primary_orders

Generally, on each purchase date, they make orders by SAT or PSAT score ranges (SAT if purchasing seniors or juniors, PSAT if purchasing juniors or sophomores):

  • Senior purchases by SAT filter
    • Sep 2017 (grad class 2018): 4 groups (A, B1, C, D)
    • Sep 2018 (grad class 2019): 4 groups (A, B2, C, D)
    • Sep 2019 (grad class 2020): 1 group (B3)
  • Junior purchases by SAT or PSAT filter
    • Sep 2017 (grad class 2019): 3 groups (C1, D, E) - PSAT
    • Feb 2018 (grad class 2019): 3 groups (B, C1, D) - PSAT
    • Sep 2018 (grad class 2020): 3 groups (C2, D, E) - PSAT
    • Feb 2019 (grad class 2020): 4 groups (B, C2, D, E) - PSAT
    • Sep 2019 (grad class 2021): 1 group (B3) - SAT
    • Apr 2020 (grad class 2021): 1 group (B3) - SAT
  • Sophomore purchases by PSAT filter
    • Sep 2017 (grad class 2020): 2 groups (B, E)
    • Feb 2018 (grad class 2020): 4 groups (A, B, C1, D)
    • Sep 2018 (grad class 2021): 3 groups (C2, D, E)
    • Feb 2019 (grad class 2021): 4 groups (B, C2, D, E)
    • Sep 2019 (grad class 2022): 1 group (C3)
distinct(primary_orders %>% select(sat_score_min, sat_score_max, psat_score_min, psat_score_max)) %>% 
  arrange(sat_score_min, sat_score_max, psat_score_min, psat_score_max) %>%
  add_column(score_range = c('A', 'B1', 'B2', 'B3', 'C', 'D', 'A', 'B', 'C1', 'C2', 'C3', 'D', 'E'), .before = 1)

Common filters:

  • GPA: A+ to C+

General observations:

  • Only purchase seniors during the Fall, and juniors and sophomores both Fall & Spring
    • For juniors and sophomores, Spring purchases generally have lower test score ranges than Fall purchases
    • Over the years, there is a slight increase in some test score ranges for all grad classes
  • Usually making multiple orders at a time w/ different test score ranges, but starting in 2019, only made 1 order covering broader score range for all grad classes
    • Also, started using SAT instead of PSAT filter for sophomores

2 Secondary market purchases (32 orders)

secondary_orders

3 Houston market purchases (20 orders)

houston_orders

4 Dallas market purchases (1 order)

dallas_orders

5 Order summaries

# Cost per student went from $0.43 to $0.45 (starting Fall 2018) to $0.47 (starting Fall 2019)
orders_rate_df <- orders_df %>% select(order_num, date_start, order_cost, num_students) %>% mutate(rate = round(order_cost / num_students, 2)) %>% arrange(rate, date_start)
orders_rate_df
orders_rate_df %>%
  ggplot(aes(x = as.character(order_num), y = num_students, fill = as.character(date_start))) + 
  geom_bar(position = 'stack', stat = 'identity') +
  scale_fill_viridis(discrete = T) +
  labs(x = '') +
  theme(
    axis.text.x=element_blank(),
    axis.ticks.x=element_blank()
  ) +
  facet_grid(~rate, scales = 'free_x', space = 'free_x')

orders_rate_df %>%
  ggplot(aes(x = as.character(order_num), y = order_cost, fill = as.character(date_start))) + 
  geom_bar(position = 'stack', stat = 'identity') +
  scale_fill_viridis(discrete = T) +
  labs(x = '') +
  theme(
    axis.text.x=element_blank(),
    axis.ticks.x=element_blank()
  ) +
  facet_grid(~rate, scales = 'free_x', space = 'free_x')

6 Maps

# Create var for race breaks
zip_data$race_brks_nonwhiteasian <- cut(zip_data$pop_poc_pct, 
                                        breaks = c(-1, 20, 40, 60, 80, 90, 101), 
                                        labels = c('0-19%', '20-39%', '40-59%', 
                                                   '60-79%', '80-89%', '90-100%'))

# Create var for income breaks
zip_data$inc_brks <- cut(zip_data$median_household_income, 
                         breaks = c(-1, 50000, 75000, 100000, 150000, 200000, 10000000), 
                         labels = c('<$50k', '$50k-74k', '$75k-99k', 
                                    '$100k-149k', '$150k-199k', '$200k+'))

# Create var for first 3 digits of zip code
zip_data$zip_code_3 <- zip_data$zip_code %>% str_sub(end = 3)

# Merge zip data to shapes
zip_shp <- merge(zip_shp, zip_data, by.x = 'ZCTA5CE10', by.y = 'zip_code', all.x = T)


# Create shared color scale functions
color_income <- colorFactor('YlGnBu', zip_shp$inc_brks)
color_race <- colorFactor('YlGnBu', zip_shp$race_brks_nonwhiteasian)
color_pop <- colorNumeric('YlGnBu', zip_shp$pop_total, n = 5)


# Plot purchased zip codes
plot_map <- function(map_data) {
  # Create popups
  pop_zip <- paste0('<b>', zip_shp_purchased$zip_name, '</b><br>',
                    'Total Population: ', format(zip_shp_purchased$pop_total, big.mark = ',')) %>% lapply(htmltools::HTML)
  
  income_zip <- paste0('<b>', zip_shp_purchased$zip_name, '</b><br>',
                       'Median Household Income: ', currency(zip_shp_purchased$median_household_income, digits = 0L)) %>% lapply(htmltools::HTML)
  
  race_zip <- paste0('<b>', zip_shp_purchased$zip_name, '</b><br>',
                     '% Population of Color: ', sprintf('%.1f', zip_shp_purchased$pop_poc_pct)) %>% lapply(htmltools::HTML)
  
  leaflet(data = map_data) %>%
    addProviderTiles(providers$CartoDB.Positron) %>%
    
    addMiniMap(tiles = providers$CartoDB.Positron,
               toggleDisplay = TRUE) %>% 
    
    addPolygons(stroke = F, fillOpacity = 0.1, smoothFactor = 0.2, color = 'gray', group = 'Purchased') %>% 
    addPolygons(stroke = F, fillOpacity = 0.8, smoothFactor = 0.2, color = ~color_pop(pop_total), label = pop_zip, group = 'By Population') %>%
    addPolygons(stroke = F, fillOpacity = 0.8, smoothFactor = 0.2, color = ~color_income(inc_brks), label = income_zip, group = 'By Median Household Income') %>%
    addPolygons(stroke = F, fillOpacity = 0.8, smoothFactor = 0.2, color = ~color_race(race_brks_nonwhiteasian), label = race_zip, group = 'By Race/Ethnicity') %>% 
    
    # add legends
    addLegend(position = 'topright', pal = color_pop, values = ~pop_total,
              title = 'Population',
              className = 'info legend legend-pop',
              na.label = 'NA',
              opacity = 1) %>%
    
    addLegend(position = 'topright', pal = color_income, values = ~inc_brks,
              title = 'Median Household Income',
              className = 'info legend legend-income',
              na.label = 'NA',
              opacity = 1) %>%
    
    addLegend(position = 'topright', pal = color_race, values = ~race_brks_nonwhiteasian,
              title = 'Black, Latinx, and <br>Native American Population',
              className = 'info legend legend-race',
              na.label = 'NA',
              opacity = 1) %>%
    
    # add options
    addLayersControl(
      position = c('bottomleft'),
      baseGroups = c('Purchased', 'By Population', 'By Median Household Income', 'By Race/Ethnicity'),
      options = layersControlOptions(collapsed = FALSE)
    ) %>%
    
    htmlwidgets::onRender("
          function(el, x) {
              var myMap = this;
              $('.legend').css('display', 'none');
              
              myMap.on('baselayerchange', function(e) {
                  $('.legend').css('display', 'none');
                  switch(e.name) {
                      case 'By Population':
                          $('.legend-pop').css('display', 'inherit');
                          break;
                      case 'By Median Household Income':
                          $('.legend-income').css('display', 'inherit');
                          break;
                      case 'By Race/Ethnicity':
                          $('.legend-race').css('display', 'inherit');
                          break;
                  }
                  e.layer.bringToBack();
              });
      }")
}

# View different sets of zip codes purchased
zip_purchased <- str_split(unique(orders_df$zip_code) %>% na.omit() %>% as.character(), '\\|')

# Primary
zip_shp_purchased <- subset(zip_shp, zip_code_3 %in% zip_purchased[[2]])
plot_map(zip_shp_purchased)
# Secondary (1, 4, 5)
zip_shp_purchased <- subset(zip_shp, zip_code_3 %in% zip_purchased[[1]])
plot_map(zip_shp_purchased)
# Houston
zip_shp_purchased <- subset(zip_shp, zip_code_3 %in% zip_purchased[[3]])
plot_map(zip_shp_purchased)